home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr46 / tpfort18.zip / OPRO.INC < prev    next >
Text File  |  1992-03-08  |  8KB  |  237 lines
  1. { This unit contains extracts from the excellent Object Professional
  2.   library by Turbopower Software, included here with their kind
  3.   permission.  If you own Object Professional, you won't need this file;
  4.   just define the OPRO_VER conditional define in the Fortlink source
  5.   code.
  6.  
  7.   If you don't own Object Professional, leave OPRO_VER undefined and this
  8.   include file will be automatically included.  However, if you don't
  9.   own Object Professional you're really missing out; I'd suggest buying
  10.   it.  You can contact TurboPower at 800-333-4160 or 719-260-6641
  11.   (voice), 719-260-7151 (fax), or by email to Compuserve ID 76004,2611
  12.   (that's 76004.2611@compuserve.com on Internet).
  13.  
  14.   Duncan Murdoch
  15. }
  16.  
  17. {$F+}   { These are all far calls! }
  18.  
  19. {*********************************************************}
  20. {*                  OPINLINE.PAS 1.10                    *}
  21. {*     Copyright (c) TurboPower Software 1987, 1989.     *}
  22. {* Portions copyright (c) Sunny Hill Software 1985, 1986 *}
  23. {*     and used under license to TurboPower Software     *}
  24. {*                 All rights reserved.                  *}
  25. {*********************************************************}
  26.  
  27. type
  28.   OS =
  29.     record
  30.       O, S : Word;
  31.     end;
  32.  
  33. procedure FarCall(ProcAddr : Pointer);
  34.   {-ProcAddr is the address of a routine to be called far. Can be used to
  35.     implement jump tables if procedures take no parameters.}
  36.   inline(
  37.     $89/$E3/                 {mov bx,sp}
  38.     $36/$FF/$1F/             {call far dword ptr ss:[bx]}
  39.     $81/$C4/$04/$00);        {add sp,4}
  40.  
  41. function Normalized(P : Pointer) : Pointer;
  42.   {-Return P as a normalized pointer}
  43.   inline(
  44.     $58/                     {pop ax    ;pop offset into AX}
  45.     $5A/                     {pop dx    ;pop segment into DX}
  46.     $89/$C3/                 {mov bx,ax ;BX = Ofs(P^)}
  47.     $B1/$04/                 {mov cl,4  ;CL = 4}
  48.     $D3/$EB/                 {shr bx,cl ;BX = Ofs(P^) div 16}
  49.     $01/$DA/                 {add dx,bx ;add BX to segment}
  50.     $25/$0F/$00);            {and ax,$F ;mask out unwanted bits in offset}
  51.  
  52. function PtrToLong(P : Pointer) : LongInt;
  53.   {-Convert pointer, in range $0:$0 to $FFFF:$000F, to LongInt}
  54. begin
  55.   PtrToLong := (LongInt(OS(P).S) shl 4)+OS(P).O;
  56. end;
  57.  
  58. function PtrDiff(P1, P2 : Pointer) : LongInt;
  59.   {-Return the number of bytes between P1^ and P2^}
  60. begin
  61.   PtrDiff := Abs(PtrToLong(P1)-PtrToLong(P2));
  62. end;
  63.  
  64. {*********************************************************}
  65. {*                    OPINT.PAS 1.10                     *}
  66. {*     Copyright (c) TurboPower Software 1987, 1989.     *}
  67. {* Portions copyright (c) Sunny Hill Software 1985, 1986 *}
  68. {*     and used under license to TurboPower Software     *}
  69. {*                 All rights reserved.                  *}
  70. {*********************************************************}
  71.  
  72. const
  73.   MaxISRs = 20;
  74. type
  75.   Dummy5 = array[1..5] of Word;
  76.   IntRegisters =
  77.     record
  78.       case Byte of
  79.         1 : (BP, ES, DS, DI, SI, DX, CX, BX, AX, IP, CS, Flags : Word);
  80.         2 : (Dummy : Dummy5; DL, DH, CL, CH, BL, BH, AL, AH : Byte);
  81.     end;
  82.   IsrRecord =
  83.     record
  84.       IntNum : Byte;         {Interrupt vector number}
  85.       OrigAddr : Pointer;    {Original vector}
  86.       NewAddr : Pointer;     {New vector}
  87.       Captured : Boolean;    {Used for error checking}
  88.     end;
  89. var
  90.   {global array of ISR records}
  91.   IsrArray : array[1..MaxISRs] of IsrRecord;
  92. var
  93.   SaveExitProc : Pointer;
  94.  
  95. procedure InterruptsOn;
  96.   {-Turn interrupts on}
  97.   inline($FB);               {sti}
  98.  
  99.   function InitVector(IntNumber, Handle : Byte; UserRoutine : Pointer) : Boolean;
  100.     {-Sets up an interrupt service routine}
  101.   begin
  102.     {assume failure}
  103.     InitVector := False;
  104.  
  105.     case Handle of
  106.       1..MaxISRs :
  107.         with IsrArray[Handle] do
  108.           if not Captured then begin
  109.             {Setup variables}
  110.             IntNum := IntNumber;
  111.             GetIntVec(IntNumber, OrigAddr);
  112.  
  113.             {Set the vector}
  114.             SetIntVec(IntNumber, UserRoutine);
  115.             NewAddr := UserRoutine;
  116.             Captured := True;
  117.             InitVector := True;
  118.           end;
  119.     end;
  120.   end;
  121.  
  122.   procedure RestoreVector(Handle : Byte);
  123.     {-Restores an interrupt vector to its original value}
  124.   begin
  125.     case Handle of
  126.       1..MaxISRs :
  127.         with IsrArray[Handle] do
  128.           if Captured then begin
  129.             SetIntVec(IntNum, OrigAddr);
  130.             Captured := False;
  131.             OrigAddr := nil;
  132.           end;
  133.     end;
  134.   end;
  135.  
  136. procedure SwapStackAndCallNear(Routine : Word; SP : Pointer;
  137.   var Regs : IntRegisters);
  138.   {-Switches to stack designated by SP and calls Routine with Regs as a
  139.     parameter. The Routine must be a NEAR call from the current ISR.}
  140.   inline(
  141.     $9C/                     {pushf        ;Load flags into AX}
  142.     $58/                     {pop ax}
  143.     $5A/                     {pop dx       ;AX = Ofs(Regs)}
  144.     $07/                     {pop es       ;ES = Seg(Regs)}
  145.     $59/                     {pop cx       ;CX = new SP}
  146.     $5F/                     {pop di       ;DI = new SS}
  147.     $5B/                     {pop bx       ;BX = offset of Routine to call}
  148.     $8C/$D6/                 {mov si,ss    ;Save SS in SI}
  149.     $FA/                     {cli          ;Force interrupts off}
  150.     $8E/$D7/                 {mov ss,di    ;Switch stack segments}
  151.     $87/$E1/                 {xchg cx,sp   ;Get new SP and save old in CX}
  152.     $50/                     {push ax      ;Restore flags}
  153.     $9D/                     {popf}
  154.     $9C/                     {pushf        ;Save flags again}
  155.     $56/                     {push si      ;Save old SS on stack}
  156.     $51/                     {push cx      ;Save old SP}
  157.     $06/                     {push es      ;Push Seg(Regs)}
  158.     $52/                     {push dx      ;Push Ofs(Regs)}
  159.     $FF/$D3/                 {call near bx ;Call Routine}
  160.     $FA/                     {cli          ;Interrupts off}
  161.     $58/                     {pop ax       ;Get back old SP}
  162.     $5A/                     {pop dx       ;Get back old SS}
  163.     $59/                     {pop cx       ;Get back old flags}
  164.     $8E/$D2/                 {mov ss,dx    ;Restore SS}
  165.     $89/$C4/                 {mov sp,ax    ;Restore SP}
  166.     $51/                     {push cx      ;Restore flags}
  167.     $9D);                    {popf}
  168.  
  169.   procedure RestoreAllVectors;
  170.     {-Restores all captured interrupt vectors}
  171.   var
  172.     I : Word;
  173.   begin
  174.     {restore in reverse order}
  175.     for I := MaxISRs downto 1 do
  176.       RestoreVector(I);
  177.   end;
  178.  
  179.   procedure OpIntExit;
  180.     {-Exit/error handler for the unit. Restores all captured interrupt vectors}
  181.   begin
  182.     ExitProc := SaveExitProc;
  183.     RestoreAllVectors;
  184.   end;
  185.  
  186.   procedure OpIntInit;
  187.     {-This sets up an array of unused ISR records}
  188.   var
  189.     I : Word;
  190.   begin
  191.     {initialize the array of ISR records}
  192.     for I := 1 to MaxISRs do
  193.       with IsrArray[I] do begin
  194.         IntNum := 0;
  195.         OrigAddr := nil;
  196.         NewAddr := nil;
  197.         Captured := False;
  198.       end;
  199.   end;
  200.  
  201. procedure OPINT_init;
  202. begin
  203.   {initialize array of ISR records}
  204.   OpIntInit;
  205.  
  206.   {set up exit handler}
  207.   SaveExitProc := ExitProc;
  208.   ExitProc := @OpIntExit;
  209. end;
  210.  
  211. {*********************************************************}
  212. {*                    OPDOS.PAS 1.10                     *}
  213. {*     Copyright (c) TurboPower Software 1987, 1989.     *}
  214. {* Portions copyright (c) Sunny Hill Software 1985, 1986 *}
  215. {*     and used under license to TurboPower Software     *}
  216. {*                 All rights reserved.                  *}
  217. {*********************************************************}
  218.  
  219.  
  220. function SetBlock(var Paragraphs : Word) : Boolean;
  221.   {-Change size of DOS memory block allocated to this program}
  222. var
  223.   Regs : Registers;
  224. begin
  225.   with Regs do begin
  226.     AH := $4A;
  227.     ES := PrefixSeg;
  228.     BX := Paragraphs;
  229.     MsDos(Regs);
  230.     Paragraphs := BX;
  231.     SetBlock := not Odd(Flags);
  232.   end;
  233. end;
  234.  
  235. {$F-}
  236.  
  237.